home *** CD-ROM | disk | FTP | other *** search
- {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~}
- { }
- { Tutor for Turbo Pascal Object-oriented Programming (version 6.0) }
- { Based on the Borland Turbo Vision program TVDEMO.PAS found on }
- { the Install diskette. }
- { }
- { Program using Turbo Vision to provide a menu screen for the }
- { selection of Turbo Pascal OOP notes and example programs. }
- { }
- { OOPTUTOR.PAS -> .EXE R Shaw Copyright 9.11.92 }
- {____________________________________________________________________}
-
- program OOPTutor;
-
- {$X+,S-}
- {$M 16384,8192,655360}
-
- { This program uses many of the Turbo Vision standard and demo units,
- including:
-
- StdDlg - Open file browser, change directory tree.
- MsgBox - Simple dialog to display messages.
- ColorSel - Color customization.
- Gadgets - Shows system time and available heap space.
- FViewer - Scroll through text files.
- HelpFile - Context sensitive help.
- MouseDlg - Mouse options dialog.
-
- And of course this program includes many standard Turbo Vision
- objects and behaviors (menubar, desktop, status line, dialog boxes,
- mouse support, window resize/move/tile/cascade).
- }
-
- uses
- Dos, Objects, Drivers, Memory, Views, Menus, Dialogs, StdDlg, MsgBox, App,
- DemoCmds, Gadgets, FViewer, HelpFile, OOPHelp, ColorSel, MouseDlg, Hexa,
- Crt;
-
- const
- cmRecInit = 110; { These are demonstration programs by R Shaw }
- cmObjInit = 111; { for the Turbo Pascal OOP course. }
- cmWrongOop = 112;
- cmRightOop = 113;
- cmJuniorOb = 114;
- cmFigDemo = 116;
- cmListDemo = 117;
- cmStreams = 118;
- cmProgOpen = 119;
- cmLOpen = 120;
- cmCollect = 121;
- cmObCompat = 122;
-
- type
-
- { TTVDemo }
-
- PTVDemo = ^TTVDemo;
- TTVDemo = object(TApplication)
- Clock: PClockView;
- Heap: PHeapView;
- constructor Init;
- procedure FileOpen(WildCard: PathStr);
- procedure GetEvent(var Event: TEvent); virtual;
- function GetPalette: PPalette; virtual;
- procedure HandleEvent(var Event: TEvent); virtual;
- procedure Idle; virtual;
- procedure InitMenuBar; virtual;
- procedure InitStatusLine; virtual;
- procedure LoadDesktop(var S: TStream);
- procedure OutOfMemory; virtual;
- procedure StoreDesktop(var S: TStream);
- procedure ViewFile(FileName: PathStr);
- end;
-
- { CalcHelpName }
-
- function CalcHelpName: PathStr;
- var
- EXEName: PathStr;
- Dir: DirStr;
- Name: NameStr;
- Ext: ExtStr;
- begin
- if Lo(DosVersion) >= 3 then EXEName := ParamStr(0)
- else EXEName := FSearch('OOPTUTOR.EXE', GetEnv('PATH'));
- FSplit(EXEName, Dir, Name, Ext);
- if Dir[Length(Dir)] = '\' then Dec(Dir[0]);
- CalcHelpName := FSearch('OOPHELP.HLP', Dir);
- end;
-
-
- { TTVDemo }
- constructor TTVDemo.Init;
- var
- R: TRect;
- I: Integer;
- FileName: PathStr;
- begin
- TApplication.Init;
- RegisterObjects;
- RegisterViews;
- RegisterMenus;
- RegisterDialogs;
- RegisterApp;
- RegisterHelpFile;
- RegisterFViewer;
-
- GetExtent(R);
- R.A.X := R.B.X - 9; R.B.Y := R.A.Y + 1;
- Clock := New(PClockView, Init(R));
- Insert(Clock);
-
- GetExtent(R);
- Dec(R.B.X);
- R.A.X := R.B.X - 9; R.A.Y := R.B.Y - 1;
- Heap := New(PHeapView, Init(R));
- Insert(Heap);
-
- for I := 1 to ParamCount do
- begin
- FileName := ParamStr(I);
- if FileName[Length(FileName)] = '\' then
- FileName := FileName + '*.*';
- if (Pos('?', FileName) = 0) and (Pos('*', FileName) = 0) then
- ViewFile(FExpand(FileName))
- else FileOpen(FileName);
- end;
- end;
-
- procedure TTVDemo.FileOpen(WildCard: PathStr);
- var
- D: PFileDialog;
- FileName: PathStr;
- begin
- D := New(PFileDialog, Init(WildCard, 'Open a File',
- '~N~ame', fdOpenButton + fdHelpButton, 100));
- D^.HelpCtx := hcFOFileOpenDBox;
- if ValidView(D) <> nil then
- begin
- if Desktop^.ExecView(D) <> cmCancel then
- begin
- D^.GetFileName(FileName);
- ViewFile(FileName);
- end;
- Dispose(D, Done);
- end;
- end;
-
- procedure TTVDemo.GetEvent(var Event: TEvent);
- var
- W: PWindow;
- HFile: PHelpFile;
- HelpStrm: PDosStream;
- const
- HelpInUse: Boolean = False;
- begin
- TApplication.GetEvent(Event);
- case Event.What of
- evCommand:
- if (Event.Command = cmHelp) and not HelpInUse then
- begin
- HelpInUse := True;
- HelpStrm := New(PDosStream, Init(CalcHelpName, stOpenRead));
- HFile := New(PHelpFile, Init(HelpStrm));
- if HelpStrm^.Status <> stOk then
- begin
- MessageBox('Could not open help file.', nil, mfError + mfOkButton);
- Dispose(HFile, Done);
- end
- else
- begin
- W := New(PHelpWindow,Init(HFile, GetHelpCtx));
- if ValidView(W) <> nil then
- begin
- ExecView(W);
- Dispose(W, Done);
- end;
- ClearEvent(Event);
- end;
- HelpInUse := False;
- end;
- evMouseDown:
- if Event.Buttons <> 1 then Event.What := evNothing;
- end;
- end;
-
- function TTVDemo.GetPalette: PPalette;
- const
- CNewColor = CColor + CHelpColor;
- CNewBlackWhite = CBlackWhite + CHelpBlackWhite;
- CNewMonochrome = CMonochrome + CHelpMonochrome;
- P: array[apColor..apMonochrome] of string[Length(CNewColor)] =
- (CNewColor, CNewBlackWhite, CNewMonochrome);
- begin
- GetPalette := @P[AppPalette];
- end;
-
- procedure TTVDemo.HandleEvent(var Event: TEvent);
-
- procedure ChangeDir;
- var
- D: PChDirDialog;
- begin
- D := New(PChDirDialog, Init(cdNormal + cdHelpButton, 101));
- D^.HelpCtx := hcFCChDirDBox;
- if ValidView(D) <> nil then
- begin
- DeskTop^.ExecView(D);
- Dispose(D, Done);
- end;
- end;
-
- procedure Tile;
- var
- R: TRect;
- begin
- Desktop^.GetExtent(R);
- Desktop^.Tile(R);
- end;
-
- procedure Cascade;
- var
- R: TRect;
- begin
- Desktop^.GetExtent(R);
- Desktop^.Cascade(R);
- end;
-
-
- procedure About;
- var
- D: PDialog;
- Control: PView;
- R: TRect;
- begin
- R.Assign(0, 0, 60, 11);
- D := New(PDialog, Init(R, 'About'));
- with D^ do
- begin
- Options := Options or ofCentered;
-
- R.Grow(-1, -1);
- Dec(R.B.Y, 3);
- Insert(New(PStaticText, Init(R,
- #13 +
- ^C'Turbo Pascal OOP Tutor and Examples'#13 +
- #13 +
- ^C'R Shaw Copyright 9.11.92'#13 +
- #13 +
- ^C'Based on a Turbo Vision program by Borland')));
-
- R.Assign(25, 8, 35, 10);
- Insert(New(PButton, Init(R, 'O~K', cmOk, bfDefault)));
- end;
- if ValidView(D) <> nil then
- begin
- Desktop^.ExecView(D);
- Dispose(D, Done);
- end;
- end;
-
- procedure Colors;
- var
- D: PColorDialog;
- begin
- D := New(PColorDialog, Init('',
- ColorGroup('Desktop',
- ColorItem('Color', 32, nil),
- ColorGroup('Menus',
- ColorItem('Normal', 2,
- ColorItem('Disabled', 3,
- ColorItem('Shortcut', 4,
- ColorItem('Selected', 5,
- ColorItem('Selected disabled', 6,
- ColorItem('Shortcut selected', 7, nil)))))),
- ColorGroup('Dialogs/Calc',
- ColorItem('Frame/background', 33,
- ColorItem('Frame icons', 34,
- ColorItem('Scroll bar page', 35,
- ColorItem('Scroll bar icons', 36,
- ColorItem('Static text', 37,
-
- ColorItem('Label normal', 38,
- ColorItem('Label selected', 39,
- ColorItem('Label shortcut', 40,
-
- ColorItem('Button normal', 41,
- ColorItem('Button default', 42,
- ColorItem('Button selected', 43,
- ColorItem('Button disabled', 44,
- ColorItem('Button shortcut', 45,
- ColorItem('Button shadow', 46,
-
- ColorItem('Cluster normal', 47,
- ColorItem('Cluster selected', 48,
- ColorItem('Cluster shortcut', 49,
-
- ColorItem('Input normal', 50,
- ColorItem('Input selected', 51,
- ColorItem('Input arrow', 52,
-
- ColorItem('History button', 53,
- ColorItem('History sides', 54,
- ColorItem('History bar page', 55,
- ColorItem('History bar icons', 56,
-
- ColorItem('List normal', 57,
- ColorItem('List focused', 58,
- ColorItem('List selected', 59,
- ColorItem('List divider', 60,
-
- ColorItem('Information pane', 61, nil))))))))))))))))))))))))))))),
- ColorGroup('Viewer',
- ColorItem('Frame passive', 8,
- ColorItem('Frame active', 9,
- ColorItem('Frame icons', 10,
- ColorItem('Scroll bar page', 11,
- ColorItem('Scroll bar icons', 12,
- ColorItem('Text', 13, nil)))))), nil))))));
-
- D^.HelpCtx := hcOCColorsDBox;
- if ValidView(D) <> nil then
- begin
- D^.SetData(Application^.GetPalette^);
- if Desktop^.ExecView(D) <> cmCancel then
- begin
- Application^.GetPalette^ := D^.Pal;
- DoneMemory; { Dispose all group buffers }
- ReDraw; { Redraw application with new palette }
- end;
- Dispose(D, Done);
- end;
- end;
-
- procedure Mouse;
- var
- D: PDialog;
- begin
- D := New(PMouseDialog, Init);
- D^.HelpCtx := hcOMMouseDBox;
- if ValidView(D) <> nil then
- begin
- D^.SetData(MouseReverse);
- if Desktop^.ExecView(D) <> cmCancel then
- D^.GetData(MouseReverse);
- end;
- end;
-
- procedure DosShell(fname:string);
- begin
- DoneSysError;
- DoneEvents;
- DoneVideo;
- DoneMemory;
- SetMemTop(HeapPtr);
- SwapVectors;
- If fname = 'D'
- then
- begin
- PrintStr('Type EXIT to return...');
- Exec(GetEnv('COMSPEC'), '');
- end
- else Exec(fname, '');
- SwapVectors;
- SetMemTop(HeapEnd);
- InitMemory;
- InitVideo;
- InitEvents;
- InitSysError;
- Redraw;
- end;
-
- procedure RetrieveDesktop;
- var
- S: PStream;
- begin
- S := New(PBufStream, Init('OOPTUTOR.DSK', stOpenRead, 1024));
- if LowMemory then OutOfMemory
- else if S^.Status <> stOk then
- MessageBox('Could not open desktop file', nil, mfOkButton + mfError)
- else
- begin
- LoadDesktop(S^);
- if S^.Status <> stOk then
- MessageBox('Error reading desktop file', nil, mfOkButton + mfError);
- end;
- Dispose(S, Done);
- end;
-
- procedure SaveDesktop;
- var
- S: PStream;
- F: File;
- begin
- S := New(PBufStream, Init('OOPTUTOR.DSK', stCreate, 1024));
- if not LowMemory and (S^.Status = stOk) then
- begin
- StoreDesktop(S^);
- if S^.Status <> stOk then
- begin
- MessageBox('Could not create OOPTUTOR.DSK.', nil, mfOkButton + mfError);
- {$I-}
- Dispose(S, Done);
- Assign(F, 'OOPTUTOR.DSK');
- Erase(F);
- Exit;
- end;
- end;
- Dispose(S, Done);
- end;
-
-
- begin
- TApplication.HandleEvent(Event);
- case Event.What of
- evCommand:
- begin
- case Event.Command of
- cmFOpen: FileOpen('*.txt');
- cmLOpen: FileOpen('List.txt');
- cmProgOpen: FileOpen('*.pas');
- cmChDir: ChangeDir;
- cmCascade: Cascade;
- cmTile: Tile;
- cmAbout: About;
- cmRecInit: DosShell('\tp\ooptutor\recinit.exe');
- cmObjInit: DosShell('\tp\ooptutor\objinit.exe');
- cmWrongOop: DosShell('\tp\ooptutor\wrongoop.exe');
- cmRightOop: DosShell('\tp\ooptutor\rightoop.exe');
- cmJuniorOb: DosShell('\tp\ooptutor\juniorob.exe');
- cmFigDemo: DosShell('\tp\ooptutor\figdemo.exe');
- cmListDemo: DosShell('\tp\ooptutor\listdemo.exe');
- cmStreams: DosShell('\tp\ooptutor\streams.exe');
- cmCollect: DosShell('\tp\ooptutor\collect.exe');
- cmObCompat: DosShell('\tp\ooptutor\obcompat.exe');
- cmDosShell: DosShell('D');
- cmColors: Colors;
- cmMouse: Mouse;
- cmSaveDesktop: SaveDesktop;
- cmRetrieveDesktop: RetrieveDesktop;
- else
- Exit;
- end;
- ClearEvent(Event);
- end;
- end;
- end;
-
- procedure TTVDemo.Idle;
-
- function IsTileable(P: PView): Boolean; far;
- begin
- IsTileable := P^.Options and ofTileable <> 0;
- end;
-
- begin
- TApplication.Idle;
- Clock^.Update;
- Heap^.Update;
- if Desktop^.FirstThat(@IsTileable) <> nil then
- EnableCommands([cmTile, cmCascade])
- else
- DisableCommands([cmTile, cmCascade]);
- end;
-
- procedure TTVDemo.InitMenuBar;
- var
- R: TRect;
- begin
- GetExtent(R);
- R.B.Y := R.A.Y+1;
- MenuBar := New(PMenuBar, Init(R, NewMenu(
- NewSubMenu('~'#240'~', hcSystem, NewMenu(
- NewItem('~A~bout', '', kbNoKey, cmAbout, hcSAbout, nil)),
- NewSubMenu('~N~otes', hcNotes, NewMenu(
- NewItem('~L~ist', '', kbNoKey, cmLOpen, hcList,
- NewLine(
- NewItem('~O~pen', 'F3', kbF3, cmFOpen, hcFOpen,
- NewItem('~C~hange dir...', '', kbNoKey, cmChDir, hcFChangeDir,
- NewLine(
- NewItem('~D~OS shell', '', kbNoKey, cmDosShell, hcFDosShell,
- NewItem('E~x~it', 'Alt-X', kbAltX, cmQuit, hcFExit, nil)))))))),
- NewSubMenu('~E~xamples code',hcExCode, NewMenu(
- NewItem('~O~pen', '', kbNoKey, cmProgOpen, hcPOpen,
- NewItem('E~x~it', 'Alt-X', kbAltX, cmQuit, hcFExit, nil))),
- NewSubMenu('~R~un examples',hcRunEx, NewMenu(
- NewItem('~R~ecInit', '', kbNoKey, cmRecinit, hcRecinit,
- NewItem('~O~bjInit', '', kbNoKey, cmObjinit, hcObjinit,
- NewItem('~W~rongOOP', '', kbNoKey, cmWrongoop, hcWrongoop,
- NewItem('R~i~ghtOOP', '', kbNoKey, cmRightoop, hcRightoop,
- NewItem('~J~uniorOb', '', kbNoKey, cmJuniorob, hcJuniorob,
- NewItem('~F~igDemo', '', kbNoKey, cmFigdemo, hcFigdemo,
- NewItem('~L~istDemo', '', kbNoKey, cmListdemo, hcListdemo,
- NewItem('~S~treams', '', kbNoKey, cmStreams, hcStreams,
- NewItem('~C~ollect','', kbNoKey, cmCollect, hcCollect,
- NewItem('O~b~Compat','', kbNoKey, cmObCompat, hcObCompat,
- nil))))))))))),
- NewSubMenu('~W~indows', hcWindows, NewMenu(
- NewItem('~R~esize/move','Ctrl-F5', kbCtrlF5, cmResize, hcWSizeMove,
- NewItem('~Z~oom', 'F5', kbF5, cmZoom, hcWZoom,
- NewItem('~N~ext', 'F6', kbF6, cmNext, hcWNext,
- NewItem('~C~lose', 'Alt-F3', kbAltF3, cmClose, hcWClose,
- NewItem('~T~ile', '', kbNoKey, cmTile, hcWTile,
- NewItem('C~a~scade', '', kbNoKey, cmCascade, hcWCascade, nil))))))),
- NewSubMenu('~O~ptions', hcOptions, NewMenu(
- NewItem('~M~ouse...', '', kbNoKey, cmMouse, hcOMouse,
- NewItem('~C~olors...', '', kbNoKey, cmColors, hcOColors,
- NewLine(
- NewItem('~S~ave desktop', '', kbNoKey, cmSaveDesktop, hcOSaveDesktop,
- NewItem('~R~etrieve desktop', '', kbNoKey, cmRetrieveDesktop, hcORestoreDesktop, nil)))))),
- nil)))))))));
- end;
-
- procedure TTVDemo.InitStatusLine;
- var
- R: TRect;
- begin
- GetExtent(R);
- R.A.Y := R.B.Y - 1;
- StatusLine := New(PStatusLine, Init(R,
- NewStatusDef(0, $FFFF,
- NewStatusKey('~F1~ Help', kbF1, cmHelp,
- NewStatusKey('~Alt-X~ Exit', kbAltX, cmQuit,
- NewStatusKey('~F3~ Open notes', kbF3, cmFOpen,
- NewStatusKey('~Alt-F3~ Close', kbAltF3, cmClose,
- NewStatusKey('~F5~ Zoom', kbF5, cmZoom,
- NewStatusKey('~F10~ Menu', kbF10, cmMenu,
- NewStatusKey('', kbCtrlF5, cmResize, nil))))))), nil)));
- end;
-
- procedure TTVDemo.OutOfMemory;
- begin
- MessageBox('Not enough memory available to complete operation.',
- nil, mfError + mfOkButton);
- end;
-
- { Since the safety pool is only large enough to guarantee that allocating
- a window will not run out of memory, loading the entire desktop without
- checking LowMemory could cause a heap error. This means that each
- window should be read individually, instead of using Desktop's Load.
- }
-
- procedure TTVDemo.LoadDesktop(var S: TStream);
- var
- P: PView;
-
- procedure CloseView(P: PView); far;
- begin
- Message(P, evCommand, cmClose, nil);
- end;
-
- begin
- if Desktop^.Valid(cmClose) then
- begin
- Desktop^.ForEach(@CloseView); { Clear the desktop }
- repeat
- P := PView(S.Get);
- Desktop^.InsertBefore(ValidView(P), Desktop^.Last);
- until P = nil;
- end;
- end;
-
- procedure TTVDemo.StoreDesktop(var S: TStream);
-
- procedure WriteView(P: PView); far;
- begin
- if P <> Desktop^.Last then S.Put(P);
- end;
-
- begin
- Desktop^.ForEach(@WriteView);
- S.Put(nil);
- end;
-
- procedure TTVDemo.ViewFile(FileName: PathStr);
- var
- W: PWindow;
- begin
- W := New(PFileWindow,Init(FileName));
- W^.HelpCtx := hcViewer;
- if ValidView(W) <> nil then
- Desktop^.Insert(W);
- end;
-
- var
- Tutor: TTVDemo;
-
- begin
- Tutor.Init;
- Tutor.Run;
- Tutor.Done;
- end.
-